home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
borland
/
bgiherc.zip
/
HERCULES.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-05-31
|
10KB
|
459 lines
UNIT HERCULES;
{ February 21, 1989 Turbo Pascal .TPU source }
{ A collection of subroutines to mani[ulate the unique aspects of the }
{ Hercules family of video cards. These are all character mode or }
{ InColor Card palette manipulation routines. All mode changes }
{ assume a 9x14 character matrix. }
INTERFACE
uses
dos;
type
ArrayOfPal = array[0..15] of byte;
ArrayOfHPal = array[0..17] of byte;
Font = array[0..4095] of byte;
ScrRec = record
CHR : char;
ATR : byte;
end;
FontMem = array[0..11] of Font;
AdapterType = (None,MDA,Herc102,Herc112,Herc222,CGA,EGAMono,EGAColor,
VGAMono,VGAColor,MCGAMono,MCGAColor);
var
AttBits : byte;
PalBits : byte;
CursorBits : byte;
Procedure Set48K;
Procedure Set4K;
Procedure SetROM;
Procedure Write48K(Text : string; AttValue, XPos, YPos : integer);
Procedure SetNormalAtt;
Procedure SetAlternateAtt;
Procedure LoadPal(PalArray : ArrayOfPal);
Procedure EnableIPal;
Procedure DisableIPal;
Procedure InitCursor(Start, Stop, Color : integer);
Procedure InitOverStrike(Position, Color : integer);
Procedure InitUnderScore(Position, Color : integer);
Procedure ClearFonts;
Procedure ResetVid;
Procedure LoadHPAL;
Procedure LoadHFNT;
Function CheckVid : AdapterType;
Function LoadFontFile(FileName : string; StartType, Planes : integer) : integer;
IMPLEMENTATION
Procedure Set48K;
begin
port[$03B4] := $14;
port[$03B5] := $5;
end;
Procedure Set4K;
begin
port[$03B4] := $14;
port[$03B5] := $1;
end;
Procedure SetROM;
begin
port[$03B4] := $14;
port[$03B5] := $0;
end;
Procedure Write48K(Text : string; AttValue, XPos, YPos : integer);
var
i : integer;
ScrPtr : integer;
ScrollPtr : integer;
Screen : array[0..1999] of ScrRec absolute $B000:0;
begin
ScrPtr := ((XPos * 80) + YPos);
For i := 1 to Length(Text) do
begin
if ScrPtr = 2000
then
begin
For ScrollPtr := 0 to 1919 do
Screen[ScrollPtr] := Screen[ScrollPtr + 80];
ScrPtr := 1920;
For ScrollPtr := 1920 to 1999 do
begin
Screen[ScrollPtr].CHR := ' ';
Screen[ScrollPtr].ATR := Lo(AttValue);
end;
end;
Screen[ScrPtr].CHR := Text[i];
Screen[ScrPtr].ATR := Lo(AttValue);
ScrPtr := ScrPtr + 1;
port[$03B4] := $0E;
port[$03B5] := Hi(ScrPtr);
port[$03B4] := $0F;
port[$03B5] := Lo(ScrPtr);
end;
end;
Procedure SetNormalAtt;
begin
AttBits := $20;
port[$03B4] := $17;
port[$03B5] := AttBits OR PalBits OR CursorBits;
end;
Procedure SetAlternateAtt;
begin
AttBits := $00;
port[$03B4] := $17;
port[$03B5] := AttBits OR PalBits OR CursorBits;
end;
Procedure LoadPal(PalArray : ArrayOfPal);
var
ResetByte : byte;
i : integer;
begin
port[$03B4] := $1C;
ResetByte := port[$03B5];
For i := 0 to 15 do
port[$03B5] := PalArray[i];
end;
Procedure EnableIPal;
begin
PalBits := $10;
port[$03B4] := $17;
port[$03B5] := AttBits OR PalBits OR CursorBits;
end;
Procedure DisableIPal;
begin
PalBits := $00;
port[$03B4] := $17;
port[$03B5] := AttBits OR PalBits OR CursorBits;
end;
Procedure InitCursor(Start, Stop, Color : integer);
begin
CursorBits := Lo(Color);
port[$03B4] := $17;
port[$03B5] := AttBits OR PalBits OR CursorBits;
port[$03B4] := $0A;
port[$03B5] := Lo(Start);
port[$03B4] := $0B;
port[$03B5] := Lo(Stop);
end;
Procedure InitOverStrike(Position, Color : integer);
begin
port[$03B4] := $16;
port[$03B5] := (Lo(Color) SHL 4) OR Position;
end;
Procedure InitUnderScore(Position, Color : integer);
begin
port[$03B4] := $15;
port[$03B5] := (Lo(Color) SHL 4) OR Position;
end;
Procedure ClearFonts;
var
FontNo : integer;
ScanLine : integer;
FontByte : FontMem absolute $B400:0;
begin
port[$03B4] := $18;
port[$03B5] := $0F;
For FontNo := 0 to 11 do
For ScanLine := 0 to 4095 do
FontByte[FontNo, ScanLine] := 0;
end;
Procedure ResetVid;
var
i : integer;
BlankChar : ScrRec;
Screen : array[0..1999] of ScrRec;
begin
AttBits := $20;
PalBits := $00;
CursorBits := $07;
SetROM;
SetNormalAtt;
DisableIPal;
InitCursor(12, 13, 7);
InitOverstrike(6, 7);
InitUnderScore(13, 7);
BlankChar.CHR := ' ';
BlankChar.ATR := 0;
For i := 0 to 1999 do
Screen[i] := BlankChar;
end;
function GetEnvironmentString(SearchString : string) : string;
{-Return a string from the environment}
type
Env = array[0..32767] of Char;
var
EPtr : ^Env;
EStr : string;
EStrLen : Byte absolute EStr;
Done : Boolean;
SearchLen : Byte absolute SearchString;
I : Word;
begin
GetEnvironmentString := '';
if SearchString = '' then
Exit;
{force upper case}
for I := 1 to SearchLen do
SearchString[I] := Upcase(SearchString[I]);
EPtr := Ptr(MemW[PrefixSeg:$2C], 0);
I := 0;
if SearchString[SearchLen] <> '=' then
SearchString := SearchString+'=';
Done := False;
EStrLen := 0;
repeat
if EPtr^[I] = #0 then begin
if EPtr^[Succ(I)] = #0 then begin
Done := True;
if SearchString = '==' then begin
EStrLen := 0;
Inc(I, 4);
while EPtr^[I] <> #0 do begin
Inc(EStrLen);
EStr[EStrLen] := EPtr^[I];
Inc(I);
end;
GetEnvironmentString := EStr;
end;
end;
if Copy(EStr, 1, SearchLen) = SearchString then begin
GetEnvironmentString := Copy(EStr, Succ(SearchLen), 255);
Done := True;
end;
EStrLen := 0;
end
else begin
Inc(EStrLen);
EStr[EStrLen] := EPtr^[I];
end;
Inc(I);
until Done;
end;
Procedure LoadHPAL;
var
ResetByte : byte;
i : integer;
HPAL : string;
ThePal : ArrayOfHPal;
PALFile : file of ArrayOfHPal;
begin
HPAL := GetEnvironmentString('HPAL');
If HPAL <> ''
then
begin
assign(PALFile, HPAL);
{$I-};
reset(PALFile);
{$I+};
If IOResult = 0
then
begin
read(PALFile, ThePal);
port[$03B4] := $1C;
ResetByte := port[$03B5];
For i := 0 to 15 do
port[$03B5] := ThePal[i];
port[$03B4] := $17;
port[$03B5] := ThePal[16];
port[$03B4] := $15;
port[$03B5] := ThePal[17];
end;
end;
end;
Procedure LoadHFNT;
var
HFNT : string;
dummy : integer;
begin
HFNT := GetEnvironmentString('HFNT');
If HFNT <> ''
then
begin
dummy := LoadFontFile(HFNT, 0, 0);
Set4K;
end;
end;
Function WhichHerc : AdapterType;
var
ReadPort : byte;
QueryLoop : integer;
RetraceToggle : integer;
begin
RetraceToggle := 0;
ReadPort := port[$03BA] AND $80;
For QueryLoop := 1 to 10000 do
If (port[$03BA] AND $80) <> ReadPort
then
begin
ReadPort := port[$03BA] AND $80;
RetraceToggle := RetraceToggle + 1;
end;
If RetraceToggle > 2
then
begin
ReadPort := port[$03BA] AND $70;
case ReadPort of
$10 : WhichHerc := Herc112;
$50 : WhichHerc := Herc222;
else WhichHerc := Herc102;
end
end
else WhichHerc := MDA;
end;
Function CheckVid : AdapterType;
var
Code : Byte;
Regs : Registers;
begin
Regs.AH := $1A;
Regs.AL := $00;
Intr($10, Regs);
If Regs.AL = $1A
then
begin
case Regs.BL of
$00 : CheckVid := None;
$01 : If WhichHerc = MDA
then CheckVid := MDA
else CheckVid := WhichHerc;
$02 : CheckV